home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / ATOMS._c < prev    next >
Text File  |  1990-10-04  |  35KB  |  922 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "errors.h"
  20. #include "atoms.h"
  21. #include "manager.h"
  22.  
  23. /*
  24. ATOM TABLE
  25. Each atom is associated with operator and clause information which is
  26. stored in an 'atomentry'.  The identifiers for atoms in the input are
  27. mapped to the corresponding entry through a hash table.  Collisions are
  28. handled by chaining together atom entries. 
  29. */
  30.  
  31. IMPORT ATOM BASEATOM,ATOMSTOP,ATOMHTOP;
  32. IMPORT STRING STRINGSTOP; 
  33. IMPORT TERM BASETERM,GLOTOP;
  34. IMPORT void ARGERROR(),ERROR(),ABORT();
  35. IMPORT TERM A0,A1,A2;
  36. IMPORT string strcat();                  /* from CLIB */
  37. IMPORT boolean WARNFLAG;       /* from prolog.c        */
  38. IMPORT boolean aSYSMODE;
  39. IMPORT ATOM heapatom(),stackatom();
  40. IMPORT STRING heapstring(),stackstring();
  41. IMPORT int INTVALUE();
  42. IMPORT void TESTATOM();
  43. IMPORT boolean UNIFY();
  44. IMPORT void wq();
  45. IMPORT void CHECKATOM();
  46.  
  47. /*
  48. EXPORT   ATOM LOOKUP(string,int,boolean);
  49. EXPORT   ATOM LOOKATOM(ATOM,int);
  50. EXPORT   ATOM atom(TERM),copyatom(ATOM),GetAtom(ATOM);
  51. EXPORT   TERM LISTREP(string);
  52. EXPORT   string NEWATOM;
  53. EXPORT  void STARTATOM(),ATOMCHAR();
  54. EXPORT   InitAtoms();
  55. EXPORT  void DOOP();
  56. EXPORT   ATOM LASTATOM;
  57. EXPORT   void InitUAtom();
  58. */
  59.  
  60.  
  61. GLOBAL ATOM LASTATOM=LAST_ATOM;
  62.  
  63. #define HASHSIZE 0x100
  64. GLOBAL ATOM  HASHTAB [HASHSIZE+1];
  65. GLOBAL int HASH_SIZE=HASHSIZE; /* for save.c */
  66.  
  67. #define hashcode(C1,C2)     ((((C1) & 0x7f)<<1)|     \
  68.                 ((((C1)?(C2):0)&0x40)>>6))
  69. #define strhash(S)     hashcode(*S,*(S+1))
  70. LOCAL int idhash(ATOM A)
  71. { register STRING index; index=longstring(A);
  72.   return hashcode(repchar(index),repchar(index+1));
  73. }
  74.  
  75. /* create an new atom */
  76.  
  77. #if !BIT8
  78. #define STRINGSPACE 256 /* Size of string buffer. */
  79. #endif
  80. #if BIT8
  81. #define STRINGSPACE 128 /* Size of string buffer. */
  82. #endif
  83.  
  84. GLOBAL char stab[STRINGSPACE]; /* also used in help.c */
  85.  
  86. string NEWATOM=stab;
  87. LOCAL int NEWINDEX;
  88.  
  89. GLOBAL void STARTATOM (void)
  90. { NEWATOM=stab; NEWINDEX=0; }
  91.  
  92. GLOBAL void ATOMCHAR (register char C)
  93. { if(NEWINDEX>=STRINGSPACE) ERROR(aSTRINGSPACEE);
  94.   stab[NEWINDEX++]=C;
  95. }
  96.  
  97. /* #if !POINTEROFFSET */
  98. LOCAL int idstrcmp(ATOM A, register string S)
  99. { register STRING index;
  100.   index=longstring(A);
  101.   while(*S==repchar(index)) {if(*S++) index++; else return 0;}
  102.   return (repchar(index) - *S);
  103. }
  104. /* #endif
  105. #if POINTEROFFSET
  106. #define idstrcmp(A,s)   strcmp(longstring(A),s)
  107. #endif
  108. */
  109. LOCAL ATOM CONSTATOM;  /* used during initialization only */
  110. LOCAL boolean INIT;
  111.  
  112. LOCAL void initfields(register ATOM A, register int AR)
  113. {
  114.       info(A)=0;
  115.       oprec(A)=0; 
  116.       clause(A)=nil_clause;
  117.       arity(A)=AR;
  118.       nextatom(A)=chainatom(A)=nil_atom;
  119. }
  120.  
  121. /* Enter an atom and return its value. */
  122. GLOBAL ATOM LOOKUP (string str, int ar, boolean heap)
  123. /*  search and create only in heap */
  124. { 
  125.     register ATOM A,OA;
  126.     ATOM NA,CHAINATOM,HASHATOM;
  127.     int cmp,H,nf;
  128.     boolean create;
  129.  
  130. /*****************************************/
  131. /*    heap=true; */
  132. /*****************************************/
  133.     OA=NA=CHAINATOM=nil_atom;
  134.     nf=0;
  135.     H=strhash(str);
  136. #if DEBUG
  137.     if(DEBUGFLAG) 
  138.     { out_1("\nLOOKUP:");out_1(str);out_1("/");out_1(itoa(ar));
  139.       out_1(heap ? " heap " : " stack ");
  140.       out_1("hash:");out_1(itoa(H));out_1(";");out_1(itoa(HASHTAB[H]));
  141.     }
  142. #endif
  143.     if(ar < 0 ) { ar= -ar; create=false;} else create=true;
  144.     if(ar > MAXARITY) ERROR(BADARITYE);
  145.     HASHATOM=HASHTAB[ H ];
  146.     if(HASHATOM) /* search in primary chain */
  147.     {
  148. #if DEBUG
  149.     if(DEBUGFLAG) 
  150.         { out_1("#"); }
  151. #endif
  152.         OA=A=HASHATOM;
  153.         while(non_nil_atom(A) && (cmp=idstrcmp(A,str)) < 0)
  154.         {OA=A;A=nextatom(A);nf++;}
  155.         if(A && cmp==0) NA=A;
  156.         while(non_nil_atom(A) && (cmp=idstrcmp(A,str))==0 && 
  157.       (hide(A) || private(A)))
  158.         {
  159. #if DEBUG
  160.             if(DEBUGFLAG)
  161.             {
  162.                 out_1("{");
  163.                 out_1(itoa(A));
  164.                 if(A)
  165.                 {
  166.                     out_1(";");out_1(itoa(cmp));
  167.                     out_1(";");out_1(itoa(hide(A)));
  168.                     out_1(";");out_1(itoa(private(A)));
  169.                     out_1(";");out_1(itoa(nextatom(A)));
  170.  
  171.                 }
  172.                 out_1("}");
  173.             }
  174. #endif
  175.             OA=A;A=nextatom(A);nf++;
  176.         }
  177.         if(!A) cmp=1;
  178.         if(A && cmp==0) /* search in secondary chain */
  179.         {
  180.         int AA,OAA;
  181. #if DEBUG
  182.             if(DEBUGFLAG) out_1("@");
  183. #endif
  184.             nf++;
  185.             CHAINATOM=NA=OA=A;
  186.         AA=OAA=arity(A);
  187.             while(non_nil_atom(A) && !(ar==AA ||
  188.                          (ar < AA && ar > OAA) ||
  189.                          (ar < AA && OAA > AA)
  190.                         ))
  191.             { OA=A; OAA=AA; A=chainatom(A); AA=arity(A);}
  192.             if( A && ar==AA) goto found;
  193.         }
  194.     }
  195.     if(!heap)  /* search atom in stack */
  196.     {
  197.         for(A=ATOMSTOP;A<MAXATOMS;inc_atom(A))
  198.             if(idstrcmp(A,str)==0)
  199.             { NA=A; if(ar==arity(A))goto found; }
  200.     }
  201.     if(create) /* create atom */
  202.     {
  203.         if(INIT) A=CONSTATOM;
  204.         else if(heap) A=heapatom();
  205.         else { STRINGSTOP=(STRING)nextatom(ATOMSTOP); A=stackatom(); }
  206.         if( NA ) longstring(A)=longstring(NA);
  207.         else if(heap) longstring(A)=heapstring(str);
  208.         else longstring(A)=stackstring(str); 
  209.         initfields(A,ar);
  210.         setfirst(A);
  211.         if(heap) 
  212.         {
  213.             if(HASHATOM==nil_atom || nf==0 )
  214.             {
  215.                 nextatom(A)=HASHTAB[H];
  216.                 HASHTAB[H]=A;goto found;
  217.             }
  218.             if(cmp !=0)  
  219.             {
  220.                 nextatom(A)=nextatom(OA);
  221.                 nextatom(OA)=A;
  222.             }
  223.             else
  224.             {
  225.                 setnotfirst(A);
  226.                 chainatom(A)=chainatom(OA);
  227.                 nextatom(A)=CHAINATOM;
  228.                 chainatom(OA)=A;
  229.                 
  230.             }
  231.         }
  232.         else
  233.             nextatom(A)= (card)STRINGSTOP;
  234.     }
  235.     else A=nil_atom;
  236.   found:
  237.     STARTATOM();
  238. #if DEBUG
  239.     if(DEBUGFLAG){ out_1(itoa(A));out_1("\n");}
  240. #endif
  241.     return A;
  242. }
  243.  
  244. LOCAL char tempstring[STRINGSPACE];
  245.  
  246. #if !POINTEROFFSET
  247. GLOBAL string tempcopy(ATOM A)
  248. { register int si; 
  249.   register STRING i;
  250.   register char CH; 
  251.   i=longstring(A); 
  252.   for(CH=repchar(i),si=0;tempstring[si++]=CH;CH=repchar(++i))
  253.      if(si>=STRINGSPACE) ERROR(ATOMSPACEE);
  254.   return tempstring;
  255. }
  256. #endif
  257.  
  258. GLOBAL ATOM modify(ATOM A)
  259. { register int si; 
  260.   register STRING i;
  261.   register char CH; 
  262.   i=longstring(A); 
  263.   for(CH=repchar(i),si=0;tempstring[si++]=CH;CH=repchar(++i))
  264.      if(si+1>=STRINGSPACE) ERROR(ATOMSPACEE);
  265.   si--; tempstring[si++]='_'; tempstring[si++]=0;
  266.   return LOOKUP(tempstring,arity(A),true);
  267. }
  268.  
  269. GLOBAL ATOM LOOKATOM(register ATOM A, register int ar)
  270. {
  271.     register ATOM OA;
  272.     ATOM AA;
  273.     boolean create;
  274.     boolean heap=false;
  275.     if(ar < 0 ) { ar= -ar; create=false;} else create=true;
  276.     if(ar > MAXARITY) ERROR(BADARITYE);
  277.     AA=A;
  278. #if DEBUG
  279.     if(DEBUGFLAG)
  280.     {
  281.         out_1("\nLOOKATOM:("),out_1(tempcopy(A)),
  282.         out_1(","),out_1(itoa(A)),out_1(","),out_1(itoa(ar));
  283.         out_1(")");
  284.     }
  285. #endif
  286.     if(A <=ATOMHTOP) /* A is an heapatom */
  287.     {
  288.         if(arity(A)==ar) return A;
  289.         if(private(A) || hide(A)) heap=true;
  290. #if DEBUG
  291.         if(DEBUGFLAG) { out_1(heap ? "<heap>" : "<stack>"); }
  292. #endif
  293.         if(!first(A)) A=nextatom(A);
  294.         OA=A;
  295.         while(non_nil_atom(A) && !(ar==arity(A) ||
  296.                      (ar < arity(A) && ar > arity(OA)) ||
  297.                      (ar < arity(A) && arity(OA) > arity(A))
  298.                     ))
  299.         { OA=A;A=chainatom(A);
  300.         }
  301.         if(A && arity(A)==ar) 
  302.         {
  303. #if DEBUG
  304.         if(DEBUGFLAG) { out_1("<found:");out_1(itoa(A));out_1(">"); }
  305. #endif
  306.             return A;
  307.         }
  308.         if(heap)
  309.             if(create)
  310.             {
  311.                 A=heapatom();
  312.                 longstring(A)=longstring(OA);
  313.                 initfields(A,ar);
  314.                 chainatom(A)=chainatom(OA);
  315.                 chainatom(OA)=A;
  316.                 nextatom(A)=  (first(OA) ? OA : nextatom(OA));
  317.                 if(private(OA))setprivate(A);
  318.                 if(hide(OA))sethide(A);
  319. #if DEBUG
  320.         if(DEBUGFLAG) { out_1("<create:");out_1(itoa(A));out_1(">"); }
  321. #endif
  322.                 return A;
  323.             }
  324.             else return nil_atom;
  325.     }
  326. #if DEBUG
  327.         if(DEBUGFLAG) { out_1("<call LOOKUP>"); }
  328. #endif
  329.     return LOOKUP(tempcopy(AA),(create ? ar : -ar),heap);
  330. }
  331.  
  332. GLOBAL ATOM atom(register TERM X)
  333. { 
  334.   if(name(X)!=DIVIDE_2) ARGERROR();
  335.   return LOOKATOM(name(arg1(X)),INTVALUE(arg2(X)));
  336. }
  337.  
  338. GLOBAL ATOM copyatom(register ATOM A)
  339. /* copy an Atom A to the heap */
  340. {
  341.     register ATOM NA;
  342.     register TERM T;
  343.     if(A <=  ATOMHTOP) return(A); /* do nothing */
  344.     NA=LOOKUP(tempcopy(A),(int)arity(A),true);
  345.     for(T=BASETERM;T<=GLOTOP;inc_term(T))
  346.       {  if(name(T)==A) name(T)=NA; }
  347.     setrc(NA); /* for reconsult */
  348.     return NA;
  349. }
  350.  
  351.  
  352. LOCAL void PRIVATE(register ATOM A)
  353. {
  354.     A=copyatom(A);
  355.     if(!first(A)) A=nextatom(A);
  356.     while(non_nil_atom(A)) { setprivate(A); A=chainatom(A); }
  357.     return;
  358. }
  359.     
  360. LOCAL void HIDE(register ATOM A)
  361. {
  362.     register string str;
  363.     register int cmp;
  364.     ATOM AA=nil_atom;
  365.     A=copyatom(A);
  366.     str=tempcopy(A);
  367.     if(!first(A)) A=nextatom(A);
  368.     while(non_nil_atom(A)) { sethide(A); A=chainatom(A); }
  369.     A=HASHTAB[strhash(str)];
  370.     while(non_nil_atom(A) && (cmp=idstrcmp(A,str)) <=0 )
  371.     {
  372.         if(cmp==0 && !hide(A) && private(A)) AA=A;
  373.         A=nextatom(A);
  374.     }
  375.     while(non_nil_atom(AA)) { setnotprivate(AA); AA=chainatom(AA); }
  376. }
  377.  
  378. GLOBAL void DOPRIVATE(void)
  379. { while(name(A0)==CONS_2)
  380.     { PRIVATE(name(arg1(A0))); A0=arg2(A0); }
  381.   if(name(A0) !=NIL_0) PRIVATE(name(A0));
  382. }
  383.  
  384. GLOBAL void DOHIDE(void)
  385. { 
  386.   while(name(A0)==CONS_2)
  387.     { HIDE(name(arg1(A0))); A0=arg2(A0); }
  388.   if(name(A0) !=NIL_0) HIDE(name(A0));
  389. }
  390.  
  391. /* A Prolog list of the characters of s: cf. 'atom'. */
  392. GLOBAL TERM LISTREP (register string S)
  393. { register TERM  X;
  394.   register int  N, LENGTH;
  395.   LENGTH=0;
  396.   while(S[LENGTH]) LENGTH++;
  397.   if(LENGTH==0) return mkatom(NIL_0);
  398.   X=mk2sons(INTT,(TERM)S[N=LENGTH-1],NIL_0,nil_term);
  399.   while(--N >=0)
  400.       X=mk2sons(INTT,(TERM)S[N],CONS_2,X);
  401.   return mkfunc(CONS_2,X);
  402. }
  403.  
  404. #define nextchain(A) (first(A) ?  nextatom(A) : nextatom(nextatom(A)))
  405. GLOBAL ATOM GetAtom(register ATOM A)
  406. {
  407.     register int count;
  408.   start:;
  409.     if(A==nil_atom) count=0;
  410.     else if(chainatom(A)) {A=chainatom(A); goto found;}
  411.     else if(nextchain(A)) 
  412.         {A=  nextchain(A);goto found;}
  413.     else count=idhash(A)+1;
  414.     while(count < HASHSIZE && HASHTAB[count]==nil_atom) count++;
  415.     if(count < HASHSIZE) A=HASHTAB[count]; 
  416.     else A=nil_atom;
  417.   found:;
  418.     if(non_nil_atom(A) && ( private(A) || hide(A))) 
  419.       goto start;
  420.     return A;
  421. }
  422.  
  423.  
  424. /************ I N I T I A L I S A T I O N ***************/
  425.  
  426. #define sysflag 0x4000
  427.  
  428. LOCAL struct { ATOM macro;
  429.   string str;
  430.   char predtype;
  431.   char optype;
  432.   PREC_TYPE  prec;
  433.        } 
  434.        
  435. InitT[] 
  436. ={
  437. #if LONGARITH
  438.     { LONGT       , "<<LONG>>"  , NORMP   , NONO , LONGSIZE       },
  439. #endif
  440. #if REALARITH 
  441.     { REALT       , "<<REAL>>"  , NORMP   , NONO , REALSIZE       },
  442. #endif
  443.     { READ_1      , "read"      , EVALP   , NONO , 1    |sysflag  },
  444.     { READ_2      , "read"      , EVALP   , NONO , 2    |sysflag  },
  445.     { WRITE_1     , "write"     , EVALP   , NONO , 1    |sysflag  },
  446.     { WRITEQ_1    , "writeq"    , EVALP   , NONO , 1    |sysflag  },
  447.     { DISPLAY_1   , "display"   , EVALP   , NONO , 1    |sysflag  },
  448.     { GET0_1      , "get0"      , EVALP   , NONO , 1    |sysflag  },
  449.     { UNGET_0     , "unget"     , EVALP   , NONO , 0    |sysflag  },
  450.     { GET_1       , "get"       , EVALP   , NONO , 1    |sysflag  },
  451.     { SKIP_1      , "skip"      , EVALP   , NONO , 1    |sysflag  },
  452.     { ASK_1       , "ask"       , EVALP   , NONO , 1    |sysflag  },
  453.     { PUT_1       , "put"       , EVALP   , NONO , 1    |sysflag  },
  454.     { CLS_0       , "cls"       , EVALP   , NONO , 0    |sysflag  },
  455.     { GOTOXY_2    , "gotoxy"    , EVALP   , NONO , 2    |sysflag  },
  456.     { EOLN_0      , "eoln"      , EVALP   , NONO , 0    |sysflag  },
  457.     { EOF_0       , "eof"       , EVALP   , NONO , 0    |sysflag  },
  458.     { NL_0        , "nl"        , EVALP   , NONO , 0    |sysflag  },
  459.     { TAB_1       , "tab"       , EVALP   , NONO , 1    |sysflag  },
  460.     { FILEE_0     , "fileerrors", EVALP   , NONO , 0    |sysflag  },
  461.     { FILEE_1     , "fileerrors", EVALP   , NONO , 1    |sysflag  },
  462.     { NFILEE_0    , "nofileerrors",EVALP  , NONO , 0    |sysflag  },
  463. #ifdef ARCHY
  464.     { SYNCLOSE_0  , "syneclose",  EVALP   , NONO , 0    |sysflag  }, 
  465.     { NSYNCLOSE_0 , "nosyneclose",EVALP   , NONO , 0    |sysflag  },
  466. #endif
  467.     { SEE_1       , "see"       , EVALP   , NONO , 1    |sysflag  },
  468.     { SEEING_1    , "seeing"    , EVALP   , NONO , 1    |sysflag  },
  469.     { SEEN_0      , "seen"      , EVALP   , NONO , 0    |sysflag  },
  470.     { TELL_1      , "tell"      , EVALP   , NONO , 1    |sysflag  },
  471.     { TELLING_1   , "telling"   , EVALP   , NONO , 1    |sysflag  },
  472.     { TOLD_0      , "told"      , EVALP   , NONO , 0    |sysflag  },
  473.     { OPEN_1      , "open"      , EVALP   , NONO , 1    |sysflag  },
  474.     { CLOSE_1     , "close"     , EVALP   , NONO , 1    |sysflag  },
  475.     { SEEK_2       , "seek"      , EVALP   , NONO , 2    |sysflag  },
  476.  
  477.     { TTYGET_1     , "ttyget"    , EVALP   , NONO , 1    |sysflag  },
  478.     { TTYPUT_1     , "ttyput"    , EVALP   , NONO , 1    |sysflag  },
  479.     { TTYGET0_1    , "ttyget0"   , EVALP   , NONO , 1    |sysflag  },
  480.     { TTYREAD_1    , "ttyread"   , EVALP   , NONO , 1    |sysflag  },
  481.     { TTYWRITE_1  , "ttywrite"   , EVALP   , NONO , 1    |sysflag  },
  482.     { TTYSKIP_1    , "ttyskip"   , EVALP   , NONO , 1    |sysflag  },
  483.     { TTYCLS_0     , "ttycls"    , EVALP   , NONO , 0    |sysflag  },
  484.     { TTYGOTOXY_2 , "ttygotoxy"  , EVALP   , NONO , 2    |sysflag  },
  485.     { TTYTAB_1     , "ttytab"    , EVALP   , NONO , 1    |sysflag  },
  486.     { TTYASK_1     , "ttyask"    , EVALP   , NONO , 1    |sysflag  },
  487.     { TTYNL_0      , "ttynl"     , EVALP   , NONO , 0    |sysflag  },
  488.  
  489.     { FNAME_2     , "$file"      , NORMP  , NONO , 2     |sysflag  },
  490.     { FASSIGN_2   , "assign"     , EVALP  , NONO , 2     |sysflag  },
  491.     { aWINDOW_0   , "window"     , EVALP  , NONO , 0     |sysflag  },
  492.     { WGET0_1     , "wget0"      , EVALP  , NONO , 1     |sysflag  },
  493.  
  494. #if WINDOWS
  495.     { BLINK_0     , "blink"      , NORMP  , NONO , 0               },
  496.     { REVERSE_0   , "reverse"    , NORMP  , NONO , 0               },
  497.     { BOLD_0      , "bold"       , NORMP  , NONO , 0               },
  498.     { UNDER_0     , "underline"  , NORMP  , NONO , 0               },
  499.     { WINDOW_6    , "window"     , NORMP  , NONO , 6               },
  500. #endif
  501.  
  502.  
  503.     { TRACE_0     , "trace"     , EVALP   , NONO , 0    |sysflag  },
  504.     { TRACE_1     , "trace"     , EVALP   , NONO , 1    |sysflag  },
  505.     { NOTRACE_0   , "notrace"   , EVALP   , NONO , 0    |sysflag  },
  506.     { ECHO_1      , "echo"      , EVALP   , NONO , 1    |sysflag  },
  507.     { WARN_1      , "warn"      , EVALP   , NONO , 1    |sysflag  },
  508.     { DEBUG_1     , "$debug"    , EVALP   , NONO , 1    |sysflag  },
  509.     { OCHECK_1    , "ocheck"    , EVALP   , NONO , 1    |sysflag  },
  510.     { SPY_1       , "spy"       , EVALP   , NONO , 1    |sysflag  },
  511.     { NOSPY_1     , "nospy"     , EVALP   , NONO , 1    |sysflag  },
  512.     { SYSMODE_1   , "sysmode"   , EVALP   , NONO , 1    |sysflag  },
  513.     { aINTERRUPT_1, "interrupt" , EVALP   , NONO , 1    |sysflag  },
  514.     { REDUCE_1    , "reducing"  , EVALP   , NONO , 1    |sysflag  },
  515.  
  516.     { ATOM_1      , "atom"      , ISATOMP , NONO , 1    |sysflag  },
  517.     { CURATOM_1   , "current_atom",BTEVALP, NONO , 1    |sysflag  },
  518.     { CUROP_3     , "current_op", BTEVALP , NONO , 3    |sysflag  },
  519.     { CURPRED_1   , "current_predicate",BTEVALP,NONO,1    |sysflag  },
  520.     { INTEGER_1   , "integer"   , ISINTEGERP,NONO, 1    |sysflag  },
  521.     { NUMBER_1    , "number"    , EVALP   , NONO , 1    |sysflag  },
  522.     { ATOMIC_1    , "atomic"    , EVALP   , NONO , 1    |sysflag  },
  523.     { LIST_1      , "list"      , EVALP   , NONO , 1    |sysflag  },
  524.     { MEMBER_2    , "member"    , BTEVALP , NONO , 2    |sysflag  },
  525.     { IS_MEMBER_2 , "memberchk" , ISMEMBP , NONO , 2    |sysflag  },
  526.     { NO_MEMBER_2 , "nonmember" , NOMEMBP , NONO , 2    |sysflag  },
  527.     { APP_3       , "sysappend" , EVALP   , NONO , 3    |sysflag  },
  528.     { COMPOUND_1  , "compound"  , EVALP   , NONO , 1    |sysflag  },
  529.     { STRING_1    , "string"    , EVALP   , NONO , 1    |sysflag  },
  530.     { VAR_1       , "var"       , ISVARP  , NONO , 1    |sysflag  },
  531.     { NONVAR_1    , "nonvar"    , EVALP   , NONO , 1    |sysflag  },
  532.     { INVAR_1     , "invar"     , EVALP   , NONO , 1    |sysflag  },
  533.     { GROUND_1    , "ground"    , EVALP   , NONO , 1    |sysflag  },
  534.     { FUNCTOR_3   , "functor"   , EVALP   , NONO , 3    |sysflag  },
  535.     { ARG_3       , "arg"       , EVALP   , NONO , 3    |sysflag  },
  536.     { NAME_2      , "name"      , EVALP   , NONO , 2    |sysflag  },
  537.     { UNIV_2      , "=.."       , EVALP   , XFXO , 700  |sysflag  },
  538.  
  539.     { DBREF_1     , "_db_ref"   , NORMP   , NONO , 1              },
  540.     { ASSERT_1    , "assert"    , EVALP   , NONO , 1    |sysflag  },
  541.     { ASSERTA_1   , "asserta"   , EVALP   , NONO , 1    |sysflag  },
  542.     { ASSERTZ_1   , "assertz"   , EVALP   , NONO , 1    |sysflag  },
  543.     { DBASS_2     , "assert"    , EVALP   , NONO , 2    |sysflag  },
  544.     { DBASSA_2    , "asserta"   , EVALP   , NONO , 2    |sysflag  },
  545.     { DBASSZ_2    , "assertz"   , EVALP   , NONO , 2    |sysflag  },
  546.     { DBASS_3     , "assert"    , EVALP   , NONO , 3    |sysflag  },
  547.     { RETRACT_1   , "retract"   , BTEVALP , NONO , 1    |sysflag  },
  548.     { DBRET_2     , "retract"   , BTEVALP , NONO , 2    |sysflag  },
  549.     { RETALL_1    , "retractall", EVALP   , NONO , 1    |sysflag  },
  550.     { ABOL_1       , "abolish"   , EVALP   , NONO , 1    |sysflag  },
  551.     { ABOL_2      , "abolish"   , EVALP   , NONO , 2    |sysflag  },
  552.     { CLAUSE_2    , "clause"    , BTEVALP , NONO , 2    |sysflag  },
  553.     { CLAUSE_3    , "clause"    , BTEVALP , NONO , 3    |sysflag  },
  554.     { CONSULT_1   , "consult"   , EVALP   , NONO , 1    |sysflag  },
  555.     { RECONSULT_1 , "reconsult" , EVALP   , NONO , 1    |sysflag  },
  556.     { LISTALL_0  ,  "listing"   , EVALP   , NONO , 0    |sysflag  },
  557.     { LISTING_1   , "listing"   , EVALP   , NONO , 1    |sysflag  },
  558.  
  559.     { CUT_0       , "!"         , CUTP    , NONO , 0    |sysflag  },
  560.     { FAIL_0      , "fail"      , FAILP   , NONO , 0    |sysflag  },
  561.     { TRUE_0      , "true"      , NORMP   , NONO , 0    |sysflag  },
  562.     { REPEAT_0    , "repeat"    , NORMP   , NONO , 0    |sysflag  },
  563.     { END_0       , "end_of_file", EVALP   , NONO , 0    |sysflag  },
  564.     { HALT_0      , "halt"      , EVALP   , NONO , 0    |sysflag  },
  565.     { EXIT_1      , "exit"      , EVALP   , NONO , 1    |sysflag  },
  566.     { ABORT_0     , "abort"     , EVALP   , NONO , 0    |sysflag  },
  567.     { RESTART_0   , "restart"   , EVALP   , NONO , 0    |sysflag  },
  568.     { CALL_1      , "call"      , NORMP   , NONO , 1    |sysflag  },
  569.     { MAIN_0      , "$main"     , NORMP   , NONO , 0              },
  570.     { SAVE_1      , "save"      , EVALP   , NONO , 1    |sysflag  },
  571.  
  572.     { IS_2        , "is"        , EVALP   , XFXO , 700  |sysflag  },
  573. #if ASSIGN
  574.     { ASSIGN_2    , "##:="        , NORMP   , XFYO , 700  |sysflag  },
  575. #endif
  576.     { LT_2        , "<"         , NORMP   , XFXO , 700  |sysflag  },
  577.     { LE_2        , "=<"        , NORMP   , XFXO , 700  |sysflag  },
  578.     { GT_2        , ">"         , NORMP   , XFXO , 700  |sysflag  },
  579.     { GE_2        , ">="        , NORMP   , XFXO , 700  |sysflag  },
  580.  
  581.     { EQ_2        , "=:="       , NORMP   , XFXO , 700  |sysflag  },
  582.     { NE_2        , "=\\="      , NORMP   , XFXO , 700  |sysflag  },
  583.  
  584.     { PLUS_2      , "+"         , NORMP   , YFXO , 500            },
  585.     { MINUS_2     , "-"         , NORMP   , YFXO , 500            },
  586.     { TIMES_2     , "*"         , NORMP   , YFXO , 400            },
  587.     { DIVIDE_2    , "/"         , NORMP   , YFXO , 400            },
  588.     { MOD_2       , "mod"       , NORMP   , YFXO , 400            },
  589.     { MINUS_1     , "-"         , NORMP   , FYO  , 300            },
  590.  
  591.     { NIL_0       , "[]"        , NORMP   , NONO , 0    |sysflag  },
  592.     { CONS_2      , "."         , NORMP   , XFYO , 300  |sysflag  },
  593.     { CURLY_0     , "{}"        , NORMP   , NONO , 0    |sysflag  },
  594.     { CURLY_1     , "{}"        , NORMP   , NONO , 1    |sysflag  },
  595.     { ARROW_2     , ":-"        , EVALP   , XFXO , 1200 |sysflag  },
  596.     { ARROW_1     , ":-"        , NORMP   , FXO  , 1200 |sysflag  },
  597.     { QUESTION_1  , "?-"        , NORMP   , FXO  , 1200 |sysflag  },
  598.     { SEMI_2      , ";"         , NORMP   , XFYO , 1100 |sysflag  },
  599.     { IMPL_2      , "->"        , NORMP   , XFYO , 1050 |sysflag  },
  600.     { COMMA_2     , ","         , NORMP   , XFYO , 1000 |sysflag  },
  601.     { NOT_1       , "not"       , NORMP   , FYO  , 800  |sysflag  },
  602.     { NOT1_1      , "\\+"       , NORMP   , FYO  , 800  |sysflag  },
  603.     { ISEQ_2      , "="         , NORMP   , XFXO , 700  |sysflag  },
  604.     { ISNEQ_2     , "\\="       , NORMP   , XFXO , 700  |sysflag  },
  605.     { EQUAL_2     , "=="        , EVALP   , XFXO , 700  |sysflag  },
  606.     { NOEQUAL_2   , "\\=="      , EVALP   , XFXO , 700  |sysflag  },
  607.     { TOP_0       , "toplevel"  , NORMP   , NONO , 0              },
  608.     { INIT_0      , "initialize", NORMP   , NONO , 0              },
  609.     { PROMPT_0    , "prompt"    , NORMP   , NONO , 0              },
  610.     { INTERRUPT_0 , "interrupt" , NORMP   , NONO , 0              },
  611.     { ERROR_2     , "error"     , NORMP   , NONO , 2              },
  612.     { UNKNOWN_1   , "unknown"   , NORMP   , NONO , 1              }, 
  613.  
  614.     { STDIN_0     , "stdin"     , NORMP   , NONO , 0              },
  615.     { STDOUT_0    , "stdout"    , NORMP   , NONO , 0              },
  616.     { STDERR_0    , "stderr"    , NORMP   , NONO , 0              },
  617.     { STDTRACE_0  , "stdtrace"  , NORMP   , NONO , 0              },
  618. #if HELP
  619.     { STDHELP_0   , "stdhelp"   , NORMP   , NONO , 0              },
  620. #endif
  621.     { ON_0        , "on"        , NORMP   , NONO , 0              },
  622.     { OFF_0       , "off"       , NORMP   , NONO , 0              },
  623.     { ALL_0       , "all"       , NORMP   , NONO , 0              },
  624.     { USER_0      , "user"      , NORMP   , NONO , 0              },
  625.     { NULL_0      , "null"      , NORMP   , NONO , 0              },
  626.     { FX_0        , "fx"        , NORMP   , NONO , 0              },
  627.     { FY_0        , "fy"        , NORMP   , NONO , 0              },
  628.     { XF_0        , "xf"        , NORMP   , NONO , 0              },
  629.     { YF_0        , "yf"        , NORMP   , NONO , 0              },
  630.     { XFX_0       , "xfx"       , NORMP   , NONO , 0              },
  631.     { XFY_0       , "xfy"       , NORMP   , NONO , 0              },
  632.     { YFX_0       , "yfx"       , NORMP   , NONO , 0              },
  633.     { CALL_0      , "call"      , NORMP   , NONO , 0              },
  634.     { PROVED_0    , "proved"    , NORMP   , NONO , 0              },
  635.     { REDO_0      , "redo"      , NORMP   , NONO , 0              },
  636.     { FAILED_0    , "failed"    , NORMP   , NONO , 0              },
  637.  
  638.     { STATS_0     , "stats"     , EVALP   , NONO , 0    |sysflag  },
  639.     { OP_3        , "op"        , EVALP   , NONO , 3    |sysflag  },
  640.     { DICT_1      , "dict"      , EVALP   , NONO , 1    |sysflag  },
  641.     { SDICT_1     , "sdict"     , EVALP   , NONO , 1    |sysflag  },
  642.     { SYS_1       , "sys"       , EVALP   , NONO , 1    |sysflag  },
  643.     { SORT_2      , "sort1"      , EVALP   , NONO , 2    |sysflag  },
  644.     { SORT0_2     , "sort"     , EVALP   , NONO , 2    |sysflag  },
  645.  
  646.     { EVALUATE_2  , "$evaluate"  , ARITHP  , NONO , 2    |sysflag  },
  647.     { DASSIGN_2    , "$dass"     , EVALP   , NONO , 2    |sysflag  },
  648.     { REDUCE_2     , "$reduce"    , EVALP   , NONO , 2    |sysflag  },
  649.     { ACOMP_1     , "$acomp"     , EVALP   , NONO , 1    |sysflag  },
  650.  
  651.     { MAXINT_0    , "maxint"    , NORMP   , NONO , 0               },
  652.     { MININT_0    , "minint"    , NORMP   , NONO , 0               },
  653.     { MAXAR_0     , "maxarity"  , NORMP   , NONO , 0           },
  654.     { MAXDEP_0    , "maxdepth"  , NORMP   , NONO , 0           },
  655. #if REALARITH
  656.     { E_0          , "e"         , NORMP   , NONO , 0              },
  657.     { PI_0         , "pi"        , NORMP   , NONO , 0              }, 
  658.     { REAL_1       , "real"      , EVALP   , NONO , 1              },
  659.     { EXP_1        , "exp"       , NORMP   , NONO , 1              },
  660.     { LN_1         , "ln"        , NORMP   , NONO , 1              },
  661.     { LOG10_1      , "log10"     , NORMP   , NONO , 1              },
  662.     { SQRT_1       , "sqrt"      , NORMP   , NONO , 1              },
  663.     { SIN_1        , "sin"       , NORMP   , NONO , 1              },
  664.     { COS_1        , "cos"       , NORMP   , NONO , 1              },
  665.     { TAN_1        , "tan"       , NORMP   , NONO , 1              },
  666.     { ASIN_1       , "asin"      , NORMP   , NONO , 1              },
  667.     { ACOS_1       , "acos"      , NORMP   , NONO , 1              },
  668.     { ATAN_1       , "atan"      , NORMP   , NONO , 1              },
  669.     { FLOOR_1      , "floor"     , NORMP   , NONO , 1              },
  670.     { CEIL_1       , "ceil"      , NORMP   , NONO , 1              },
  671.     { POWER_2      , "**"        , NORMP   , XFYO , 350            },
  672.     { ENTIER_1    , "entier"    , NORMP   , NONO , 1              },
  673. #endif
  674.     { LSHIFT_2    , "<<"        , NORMP   , XFYO , 600            },
  675.     { RSHIFT_2    , ">>"        , NORMP   , XFYO , 600            },
  676.     { BITAND_2    , "&"         , NORMP   , XFYO , 650            },
  677.     { BITOR_2     , "\\"        , NORMP   , XFYO , 650            },
  678.     { AND_2        , "&&"        , NORMP   , XFYO , 650            },
  679.     { OR_2         , "\\\\"      , NORMP   , XFYO , 650            },
  680.     { NEG_1        , "/"         , NORMP   , FYO  , 300            },
  681.     { BITNEG_1    , "~"          , NORMP   , FYO , 300              },
  682.     { IDIV_2       , "//"        , NORMP   , YFXO , 400            },
  683.     { ALT_2        , "@<"        , EVALP   , XFXO , 700  |sysflag  },
  684.     { ALE_2        , "@=<"       , EVALP   , XFXO , 700  |sysflag  },
  685.     { AGT_2        , "@>"        , EVALP   , XFXO , 700  |sysflag  },
  686.     { AGE_2        , "@>="       , EVALP   , XFXO , 700  |sysflag  },
  687.     { AEQ_2        , "@="        , EVALP   , XFXO , 700  |sysflag  },
  688.     { ANE_2        , "@\\="      , EVALP   , XFXO , 700  |sysflag  },
  689.     { EVAL_1       , "eval"      , NORMP   , NONO , 1              },
  690.     { QUOTE_1      , "`"         , NORMP   , FYO  , 650            },
  691.     { NL_2        , "\n"        , NORMP   , XFYO , 999            },
  692.     { VERSION_0   , "version"   , EVALP   , NONO , 0   |sysflag   },
  693.     { PRIVATE_1   , "private"   , EVALP   , NONO , 1   |sysflag   },
  694.     { HIDE_1      , "hide"      , EVALP   , NONO , 1   |sysflag   },
  695.     { ENSURE_3    , "ensure"    , EVALP   , NONO , 3   | sysflag  },
  696.     { ANCESTORS_1 , "ancestors" , EVALP   , NONO , 1   | sysflag  },
  697.     { GOTO_1      , "$goto"     , GOTOP   , NONO , 1   | sysflag   },
  698.  
  699.     { OPSYS_1     , "operating_system",EVALP,NONO, 1    |sysflag  },
  700.     { TIMER_1     , "timer"     , EVALP   , NONO , 1    |sysflag  },
  701.     { ARGC_1      , "argc"      , EVALP   , NONO , 1    |sysflag  },
  702.     { ARGV_2      , "argv"      , EVALP   , NONO , 2    |sysflag  },
  703.  
  704. #if !CPM
  705.     { TIME_3      , "time"      , EVALP   , NONO , 3    |sysflag  },
  706.     { DATE_3      , "date"      , EVALP   , NONO , 3    |sysflag  },
  707.     { WEEKDAY_1   , "weekday"   , EVALP   , NONO , 1    |sysflag  },
  708.     { GETENV_2    , "getenv"    , EVALP   , NONO , 2   | sysflag  },
  709. #if !RISCOS
  710.     { PUTENV_2    , "putenv"    , EVALP   , NONO , 2    |sysflag  },
  711. #endif
  712.     { SYSTEM_1    , "system"    , EVALP   , NONO , 1    |sysflag  },
  713. #endif
  714.  
  715. #if HELP
  716.     { HELP_0      , "help"      , EVALP   , NONO , 0   | sysflag  },
  717.     { HELP_1      , "help"      , EVALP   , NONO , 1   | sysflag  },
  718. #endif
  719.  
  720. #if DBASE3
  721.     { OPENDBF_2   , "opendbf"   , EVALP   , NONO , 2   | sysflag  },
  722.     { CREATEDBF_2 , "createdbf" , EVALP   , NONO , 2   | sysflag  },
  723.     { CLOSEDBF_1  , "closedbf"  , EVALP   , NONO , 1   | sysflag  },
  724.     { READDBF_3   , "readdbf"   , BTEVALP , NONO , 3   | sysflag  },
  725.     { WRITEDBF_3  , "writedbf"  , EVALP   , NONO , 3   | sysflag  },
  726.     { SEEKDBF_2   , "seekdbf"   , EVALP   , NONO , 2   | sysflag  },
  727.     { ERASEDBF_2  , "erasedbf"  , EVALP   , NONO , 2   | sysflag  },
  728. #endif
  729.  
  730. #if SYMBOLARITH
  731.     { COLON_2     , ":"         , NORMP   , XFYO , 600     },
  732.     { INL_1       , "inl"       , NORMP   , NONO , 1       },
  733.     { INR_1       , "inr"       , NORMP   , NONO , 1       },
  734.     { SPREAD_2    , "spread"    , NORMP   , NONO , 2       },
  735.     { DECIDE_3    , "decide"    , NORMP   , NONO , 3       },
  736.     { IND_4       , "ind"       , NORMP   , NONO , 4       },
  737.     { INT_EQ_4    , "int_eq"    , NORMP   , NONO , 4       },
  738.     { LISTIND_3   , "list_ind"  , NORMP   , NONO , 3       },
  739.     { LAMBDA_1    , "lambda"    , NORMP   , NONO , 1       },
  740.     { SUBST_3     , "subst"     , NORMP   , NONO , 3       },
  741.     { SUBST_4     , "subst"     , EVALP   , NONO , 4       },
  742.     { RECIND_3    , "rec_ind"   , NORMP   , NONO , 3       },
  743.     { TILDE_0     , "~"         , NORMP   , NONO , 0       },
  744.     { OF_2        , "of"        , NORMP   , YFXO , 250     },
  745.     { SUCC_1      , "s"         , NORMP   , NONO , 1       },
  746.     { PRED_1      , "p"         , NORMP   , NONO , 1       },
  747.     { PIND_3      , "p_ind"     , NORMP   , NONO , 3       },
  748. #endif
  749.  
  750. #if HACKY
  751.     { iCHOICEP_1 , "$$choicep"  , EVALP   , NONO , 1 |sysflag},
  752.     { iHEAPT_1   , "$$heapt"    , EVALP   , NONO , 1 |sysflag},
  753.     { iSTACKT_1  , "$$stackt"   , EVALP   , NONO , 1 |sysflag},
  754.     { iAHEAPT_1  , "$$aheapt"   , EVALP   , NONO , 1 |sysflag},
  755.     { iASTACKT_1 , "$$astackt"  , EVALP   , NONO , 1 |sysflag},
  756.     { iENV_1     , "$$env"      , EVALP   , NONO , 1 |sysflag},
  757.     { iTRAIL_1   , "$$trail"    , EVALP   , NONO , 1 |sysflag},
  758.     { iNROFCALLS_2,"$$nrofcalls", EVALP   , NONO , 2 |sysflag},
  759. #endif
  760.  
  761. #if CPM
  762.     { BDOS_3      , "bdos"      , EVALP   , NONO , 3 |sysflag},
  763.     { PEEK_3      , "peek"      , EVALP   , NONO , 3 |sysflag},
  764.     { POKE_2      , "poke"      , EVALP   , NONO , 2 |sysflag},
  765. #endif
  766.  
  767.     { 0           , "\0"        , 0       , 0    , 0       }
  768.  };
  769.  
  770.  
  771. GLOBAL void InitAtoms(void)
  772. { register int I;
  773.   int Arity,Oprec,Predtype,Optype;
  774.   string Name;
  775.   ATOM A; 
  776.   for(I=0;I<HASHSIZE;I++) HASHTAB[I]=nil_atom; /* ??? */
  777.   INIT=true;
  778.   nextatom(MAXATOMS)=MAXSTRINGS;
  779.   for(I=0;InitT[I].macro;I++)
  780.     { CONSTATOM=InitT[I].macro;
  781.       Name=InitT[I].str; 
  782.       Optype=InitT[I].optype;
  783.       Predtype=InitT[I].predtype;
  784.       Oprec=InitT[I].prec & ~sysflag;
  785.       switch(Optype)
  786.  { case XFXO: case XFYO : case YFXO : Arity=2; break;
  787.           case NONO : Arity=Oprec; Oprec=0; break;
  788.           default: Arity=1; break;
  789.         }
  790.       A=LOOKUP(Name,Arity,true);
  791.       oprec(A)=Oprec; 
  792.       if(InitT[I].prec & sysflag) setsystem(A);
  793.       setoclass(A,Optype); setclass(A,Predtype);
  794.     }
  795.   INIT=false;
  796.   nextatom(ATOMSTOP)=(card)STRINGSTOP;
  797.   setclass(UNBOUNDT,VARP); setsystem(UNBOUNDT);
  798.   setclass(VART,VARP); setsystem(VART);
  799.   setclass(SKELT,VARP); setsystem(SKELT);
  800.   setclass(INTT,VARP); setsystem(INTT);
  801. }
  802.  
  803. #if USER
  804. GLOBAL void InitUAtom(int Phase, int Macro, string Name, int Predtype, 
  805.                       int Optype, int Oprec, int System)
  806. { int Arity;
  807.   ATOM A; 
  808.   /* InitUAtom(0,...) is called at the very beginning
  809.      from  InitUser(0)  and sets  LASTATOM and ATOMHTOP ;
  810.      InitUAtom(1,...) is called from InitUser(1) after
  811.      InitAtoms()  and InitDatabase() 
  812.   */
  813.   if(Phase==0) 
  814.      { inc_atom(LASTATOM); inc_atom(ATOMHTOP); return; }
  815.   INIT=true;
  816.   CONSTATOM=Macro;
  817.   STARTATOM();
  818.   switch(Optype)
  819.        { case XFXO: case XFYO : case YFXO : Arity=2; break;
  820.           case NONO : Arity=Oprec; Oprec=0; break;
  821.           default: Arity=1; break;
  822.         }
  823.   A=LOOKUP(Name,Arity,true);
  824.   oprec(A)=Oprec; 
  825.   if(System) setsystem(A); 
  826.   setoclass(A,Optype); setclass(A,Predtype);
  827.   INIT=false;
  828. }
  829. #endif
  830.  
  831.  
  832. GLOBAL boolean DONAME (void)
  833. { 
  834.   switch(name(A0))
  835.   {
  836.         case INTT:  return UNI(A1,LISTREP(itoa(ival(A0))));
  837. #if LONGARITH
  838.         case LONGT: return UNI(A1,LISTREP(ltoa(longval(A0))));
  839. #endif
  840. #if REALARITH
  841.         case REALT: return UNI(A1,LISTREP(ftoa(realval(A0))));
  842. #endif
  843.         case UNBOUNDT: 
  844.             {
  845.                 register TERM  X;
  846.                 register int C;
  847.                 STARTATOM();
  848.                 X=A1;
  849.                 while(name(X)==CONS_2)
  850.                 { 
  851.                     C=INTVALUE(arg1(X));
  852.                     if(C <=0 || C > 255) ARGERROR();
  853.                     ATOMCHAR(C);
  854.                     X=arg2(X);
  855.                 }
  856.                 TESTATOM(NIL_0,X);
  857.                 ATOMCHAR(0);
  858.                 return UNI(A0,mkatom(LOOKUP(NEWATOM,0,false)));
  859.             }  
  860.         default: CHECKATOM(A0);
  861.                  return UNI(A1,LISTREP(tempcopy(name(A0))));
  862.     }
  863. }
  864.  
  865. GLOBAL void DOOP (void)
  866. { 
  867.     PREC_TYPE P;
  868.     ARITY_TYPE ARITY;
  869.     ATOM  A;
  870.     int F,F1,F2; /* OpType */
  871.     TERM T;
  872.   
  873.     if( (P=INTVALUE(A0)) < 0 || P > MAXPREC) ARGERROR();
  874.     if(name(A2)!=CONS_2) CHECKATOM(A2);
  875.     switch(A=name(A1))
  876.     { 
  877.         case FX_0:   F=FXO ; ARITY=1; break;
  878.         case FY_0:   F=FYO;  ARITY=1; break; 
  879.         case XF_0:   F=XFO;  ARITY=1; break;
  880.         case YF_0:   F=YFO;  ARITY=1; break;
  881.         case XFX_0:  F=XFXO; ARITY=2; break;
  882.         case XFY_0:  F=XFYO; ARITY=2; break; 
  883.         case YFX_0:  F=YFXO; ARITY=2; break; 
  884.         default:     ARGERROR();
  885.     }
  886.     if(P==0) F=NONO;
  887.     do
  888.     {
  889.         if(name(A2)==CONS_2)
  890.         {
  891.             T=arg1(A2); A2=arg2(A2);
  892.             if(name(A2)==NIL_0) A2=nil_term;
  893.         }
  894.         else 
  895.         {
  896.             T=A2; A2=nil_term;
  897.         }
  898.         CHECKATOM(T);
  899.         F1=oclass(LOOKATOM(name(T),-1));
  900.         F2=oclass(LOOKATOM(name(T),-2));
  901.         /* A must be copy to heap, because some infos are global */
  902.         A=copyatom( LOOKATOM(name(T),ARITY) );
  903.         if(system(A) && !aSYSMODE) ERROR(SYSPROCE);
  904.         if(WARNFLAG && P)
  905.         {
  906.           if(oclass(A) !=NONO)
  907.           { ws("WARNING: redeclaration of operator ");
  908.             wq(A);ws("/"); wi(ARITY);ws("\n");
  909.           }
  910.           if( /* infix-postfix-conflict */ 
  911.              ((F==XFXO || F==XFYO || F==YFXO)&&(F1==FXO || F1==FYO)) ||
  912.              ((F==XFO || F==YFO)&&(F2==XFXO || F2==XFYO || F2==YFXO)))
  913.           { ws("WARNING: possibly conflicting infix/postfix ");
  914.             ws("declaration for "); wq(A); ws("\n");
  915.           }
  916.         }
  917.         setoclass(A,(int)F); oprec(A)=P;
  918.     } while(A2 !=nil_term);
  919. }
  920.  
  921.  
  922.